home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Yerk 3.64 ƒ / Module source / docmod < prev    next >
Encoding:
Text File  |  1993-06-18  |  10.3 KB  |  366 lines  |  [TEXT/ttxt]
  1. :module docmod
  2.  
  3. // ctl
  4. // ctlwind
  5. // vscroll
  6. // textedit
  7.  
  8. 0 value eop
  9.  
  10. : getWidth    option?
  11.     IF -1 -> eop ELSE getvrect: actw drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop THEN ;
  12.  
  13.  
  14. : (marks) ( cfa filemk --)
  15.     over @ = IF  >name dup
  16.                   8 .r  3 spaces n>count type out eop >
  17.                   IF cr 0 -> out ELSE 26 out over mod - spaces THEN
  18.              ELSE drop
  19.              THEN ?pause ;
  20.  
  21. \ same as 'words'..lists all filemarks
  22. \ hold down option key to get single column
  23. : marks  getWidth 0 -> out
  24.     base >r hex
  25.     'c (marks) filemk trav cr
  26.     r> -> base ; 
  27.  
  28.  
  29. 0 value mkCfa    \ the file mark cfa
  30.  
  31. \ define a word to check each cfa in the fmark vocab, and if it is earlier
  32. \  in the dictionary than the cfa of the word we are testing to see which
  33. \  file it is in, then we must have found the mark...set a flag.
  34. : (findMk)    \ ( cfa wordcfa -- )  
  35.            over > IF dup  -> mkCfa @ filemk = -> endTrav? ELSE drop THEN ;
  36.     
  37. \ find first mark above the wordcfa - returns true if mark found
  38. : findFMark    \ ( wordcfa -- cfa t or f)        - could also be addr
  39.     LoCase
  40.     'c (findMk)  swap trav
  41.     UpCase
  42.     endTrav? IF mkCfa true ELSE false THEN ;
  43.  
  44. \ get source name from mark
  45. : srcName  ( cfa -- addr len) findFMark not abort" No Mark"
  46.      >name n>count  ;
  47.  
  48. : (forget) ( pfa --)    dup nfa >line -> dp lfa @ current ! ;
  49.  
  50. : mforget LoCase [compile] ' (forget) Upcase ;
  51.  
  52. \ forget to last mark
  53. : FM here findFMark 0= abort" no mark found"
  54.      >body (forget) ;
  55.  
  56.  
  57. \ reload last file, forgetting to mark
  58. : RL here srcname fm new: loadfile
  59.     name: topfile interpret: topfile remove: loadfile ;
  60.  
  61. \ *** reload sources from named mark
  62.  
  63. string LoadList    \ make the filelist here
  64. string tempStr    \ use in place of parmstr, since parmstr defined in Frontend
  65.  
  66. \ identify all source names from latest to the entered mark and fill filelist
  67. : (files) ( cfa cfa0 --)
  68.     over <=
  69.     IF dup @ filemk =
  70.         IF " // " put: tempStr >name n>count add: tempStr  13 +: tempStr lock: tempStr
  71.            get: tempStr start: LoadList insert: LoadList unlock: tempStr
  72.         ELSE drop THEN
  73.     ELSE drop true -> endTrav?
  74.     THEN ;
  75.  
  76. \ find filenames
  77. : files ( -- pfa) new: tempStr
  78.     clear: LoadList 'c (files) locase [compile] ' dup >r upcase 4- latest (trav) r>
  79.     release: tempStr ;
  80.  
  81. : loadKey
  82.     next: LoadList 0=
  83.     IF rekey 13 THEN ;    \ simulate a terminal cr
  84.  
  85. \ interpret from the scrap
  86. : Doit size: loadlist 0>
  87.     IF start: loadlist 'c loadKey -> keyVec  THEN sp! mp! quit ;
  88.  
  89. \ interpret LoadList
  90. : reload loadKey doit ;
  91.  
  92.  
  93. \ make file list, forget to the mark, and the reload the list.
  94. \ usage:  /// filename
  95. \ will rebuild from 'filename' to latest
  96. : /// new: LoadList files (forget) reload release: LoadList ;
  97.  
  98.  
  99. \ 1.31.92    rfl    modified recalscroll
  100. \ DISABLE MESSAGE SENT AFTER CLOSED!!!
  101.  
  102. \ class that is only for displaying scrolling, word wrapped text
  103. \  has a vertical scroll bar attached at right, with grow box.
  104. \  scroll region is entire window minus the scroll bar
  105. :CLASS TeScrollRect <super TextEdit
  106.  
  107.     var        myVScroll        \ scrollbar ptr
  108.     rect    boundsRect        \ turns out is content region 
  109.     int        atLine            \ internal use for keeping text at same line after grow
  110.     var        myWindow        \ used to determine if window is active for scroll bar
  111.  
  112.   :M putScroll: ( n --) put: myVScroll ;M
  113.  
  114.   :M lineHeight: ( -- n) m@ >ptr 24 + w@ ;M
  115.   :M nlines: ( -- n) m@ >ptr 94 + w@ ;M
  116.  
  117.   :M putLine: ( n --) put: atLine ;M
  118.  
  119. \ returns top line
  120.   :M where: ( -- line#)  getTopY: destrect    \ subtract y0 of original dest rect    
  121.     m@ >ptr getTopY: rect - lineHeight: self / ;M    \ get y0 of internal dest rect
  122.  
  123. \  :M topChar: m@ >ptr 96 + where: self 2* + w@ ;M
  124.  
  125. \ get number of whole lines
  126.   :M visibleLines: ( -- n) ptr: self 8+ size: rect swap drop lineheight: self / ;M
  127.  
  128. \ boundsRect of two textctls can't be too close vertically: > 4 pixels 
  129.   :M putRect: { l t r b  -- } l t r b put: boundsRect
  130.     l 4+ t 2+ r 18 - b 2-  putRect: super m@
  131.     IF get: destRect drop over visibleLines: self lineHeight: self * +
  132.         ptr: self 8+ put: rect
  133.     THEN ;M
  134.  
  135. \ return max first line
  136.   :M maxRange: ( -- n) nlines: self visibleLines: self -  1+ ;M
  137.  
  138.   :M new: { myWind -- } myWind put: myWindow
  139.     myWind new: super
  140.     getBotX: boundsRect 15 - getTopY: boundsRect
  141.     size: boundsRect swap drop myWind new: [ obj: myVScroll ]
  142.     disable: [ obj: myVScroll ]
  143.     1 1 putRange: [ obj: myVScroll ] ;M
  144.  
  145.   :M close: close: [ obj: myVScroll ] close: super  ;M
  146.  
  147.   :M draw: pushPort set: [ obj: myWindow ] draw: super popPort ;M
  148.  
  149. \ move text record to line# as first line in rect
  150.   :M moveto: { line# \ y -- } 0
  151.     line#  maxRange: self 1- min 0 max \ negate  \ where we want it to be
  152.     where: self                                \ where are we now?
  153.     - lineHeight: self * negate                \ translate to pixel offset
  154.     m@ >ptr offset: rect line# put: atLine draw: self
  155.     where: self 1+ put: [ obj: myVScroll ] ;M
  156.  
  157. \ recalibrate scroll bar size, range, and set text
  158.   :M recalScroll: 1 maxRange: self 1 max
  159.     putRange: [ obj: myVScroll ]
  160.     nlines: self visibleLines: self > active: [ obj: myWindow ] and
  161.     IF enable: [ obj: myVScroll ] THEN
  162.      get: atLine maxRange: self 1- min 0 max moveto: self            \ stay at about where we were before grow
  163.       ;M
  164.     
  165.   :M find: { addr len \ myText offset off1 -- offset line T or F }
  166.         heap> sarray -> myText new: myText 13 putChar: mytext
  167.         getText: super place: myText
  168.         start: myText addr len myText indexof: string
  169.         IF 1- -> offset
  170.              ptr: myText offset + bl parse -> off1 drop
  171.              bl parse offset + off1 + offset swap setSelect: self 2drop
  172.             limit: myText 1
  173.             DO offset i ^elem: myText 0 ^elem: myText - <
  174.                 IF i leave THEN
  175.             LOOP moveto: self recalscroll: self
  176.         THEN release: myText dispose> myText ;M
  177.  
  178. \ recal really slows things down
  179.   :M addText: ( addr len --) addtext: super recalScroll: self ;M
  180.  
  181.   :M put: ( addr len --) clear: super addText: self ;M
  182.  
  183.   :M grow: ( l t r b -- ) where: self put: atLine
  184.      putRect: self
  185.     16 size: boundsRect swap drop 15 - size: [ obj: myVScroll ]
  186.     getBotX: boundsRect 15 - getTopY: boundsRect moveto: [ obj: myVScroll ]
  187.     recal: self
  188.     recalScroll: self ( draw: self)  ;M
  189.  
  190.   :M activate: activate: super enable: [ obj: myVScroll ] ;M
  191.   :M deactivate: deactivate: super disable: [ obj: myVScroll ] ;M
  192. \  :M exec: activate: self click: super ;M
  193.  
  194. ;CLASS
  195.  
  196.  
  197. \ class to contain the teScrollRect
  198. :CLASS ScrollWind <super ctlWind
  199.  
  200.     var     myTextPane    \ pointer to teScrollRect
  201.  
  202.   :M putPane: ( n --) put: myTextPane ;M
  203.  
  204.   :M close:  close: [ obj: myTextPane ] close: super ;M
  205.  
  206. \ draw only the grow box, no horizontal scroll lines
  207.   :M clipGrow: { \ b r scratchRgn -- } 
  208.     get: growFlg
  209.     IF 0 call NewRgn -> scratchRgn
  210.         scratchRgn call getClip
  211.         getRect: self 2swap 2drop -> b -> r
  212.         r 15 - 0 r b put: tempRect clip: tempRect
  213.         @xy (abs) call DrawGrowIcon gotoxy
  214.         scratchRgn call setClip scratchRgn call disposeRgn
  215.     THEN ;M
  216.  
  217. \ same draw as window, except that we clip the grow rect when drawing it.
  218.     :M  DRAW:    get: fPrect
  219.         (abs) call BeginUpdate
  220.         savePort @xy set: self
  221.         clipGrow: self
  222.         exec: draw    gotoxy    \ call user draw routine
  223.         (abs) call EndUpdate 
  224.         put: fPrect 
  225.         draw: [ obj: myTextPane ] restport ;M
  226.  
  227.     \ ( -- )  response to activate event - want to draw only grow rect
  228.     :M  ENABLE:  
  229.         ^base -> actW                \ commence idle handler
  230.         set: self
  231.         clipGrow: self
  232.         activate: [ obj: myTextPane ]
  233.         exec: Enact ;M
  234.  
  235.   :M disable: deactivate: [ obj: myTextPane ]
  236.         0 -> actw clipGrow: self exec: deact ;M
  237.  
  238.   :M (grow): getVrect: self put: temprect -4 0 offset: temprect clear: temprect
  239.         getrect: self 2+ swap 1+ swap put: temprect -1 -1 offset: temprect
  240.         get: temprect grow: [ obj: myTextPane ] ;M
  241.  
  242.  :M grow: Get: growFlg
  243.         IF     0 (abs) Where: fEvent  abs: growrect
  244.             call GrowWindow -dup
  245.             IF unpack size: self (grow): [ ^base ] setView: self THEN
  246.         THEN  select: self ;M
  247.  
  248.   :M new: alive: super not
  249.     IF new: super ^base new: [ obj: myTextPane ] 
  250.         setLimits: self \ activate: [ obj: myTextPane ]
  251.         (grow): [ ^base ]
  252.     THEN ( select: self) ;M
  253.  
  254.  
  255.   :M addText: ( addr len --) alive: self
  256.     IF pushPort >r set: self addText: [ obj: myTextPane ] r> popPort
  257.     ELSE 2drop
  258.     THEN ;M
  259.  
  260.   :M print: ( addr len --) alive: self
  261.     IF pushPort >r set: self put: [ obj: myTextPane ] r> popPort
  262.     ELSE 2drop
  263.     THEN ;M
  264.  
  265.   :M key: { char -- } char $ ff and -> char
  266.         command?
  267.         IF char 
  268.             CASE
  269.                 ascii c  char ascii C = or    OF teCopy:  [ obj: myTextPane ]    ENDOF
  270.                 ascii x  char ascii X = or    OF teCut:   [ obj: myTextPane ] ENDOF
  271.                 ascii v  char ascii V = or    OF tePaste: [ obj: myTextPane ]    ENDOF
  272.             ENDCASE
  273.         ELSE  char key: [ obj: myTextPane ]
  274.         THEN ;M
  275.  
  276.   :M content:
  277.     pushPort ^base set: grafPort ^base ctlhit? not
  278.     IF select: self click: [ obj: myTextPane ]
  279.     THEN  popPort ;M
  280.  
  281.   :M idle: ptIn: [ obj: myTextPane ]
  282.         IF ibeamCurs idle: [ obj: myTextPane ] ELSE arrowCurs THEN exec: idle ;M
  283.  
  284. ;CLASS
  285.  
  286. \ instantiate objects
  287. ScrollWind dwind
  288. tescrollrect dPane
  289. vscroll dscroll
  290. dscroll putScroll: dPane
  291. dPane putPane: dwind
  292.  
  293. \ 2  2 270 120 putrect:    dPane
  294.  
  295. 270 61 640 300 true setgrow: dwind
  296.  
  297. : buildDWind pushPort alive: dwind not
  298.     IF  2 40 542 200 put: temprect
  299.         temprect 0 0 docwind false true new: dwind
  300.     THEN dup call selectWindow popPort ;
  301.  
  302. : lndn get: myCtl 1+ dup put: myCtl maxRange: dPane <=
  303.     IF 0 lineHeight: dPane negate scroll: dPane THEN ;
  304. : lnup get: myCtl 1- dup put: myCtl  0>
  305.     IF 0 lineHeight: dPane  scroll: dPane THEN ;
  306. : pgdn get: myCtl visibleLines: dPane 1- + put: myCtl get: myCtl 1- moveto: dPane ;
  307. : pgup get: myCtl visibleLines: dPane 1- - put: myCtl get: myCtl 1- moveto: dPane ;
  308. : doth get: myCtl put: myCtl get: myCtl 1- moveto: dPane ;
  309.  
  310. 5 'cfas lnup lndn pgup pgdn doth actions: dscroll
  311.  
  312. 0 value srcOpen    \ store mkcfa or 0.
  313.  
  314. : NoSrc false -> srcOpen ;
  315.  
  316. 4 'cfas NoSrc null null null actions: dwind
  317.  
  318. : loadr ( addr len --)
  319.     new: loadfile
  320.      name: topFile
  321.     open: topFile dup konstant fnfErr =
  322.     abort" file not in pathList"
  323.     abort" file error"
  324.     topFile size: topFile read: tempstr drop
  325.     builddwind
  326.     getName: topFile title: dwind
  327.     remove: loadfile   ;
  328.  
  329. : see { \ xline wordPfa -- }
  330.     docs 0= abort" +docs not set"
  331.     @word count sfind
  332.     IF drop -> wordPfa
  333.         wordPfa nfa >line w@ extend -> xline
  334.         xline -1 <>
  335.         IF wordPfa findfmark
  336.             IF    srcOpen <>
  337.                 IF  new: tempStr
  338.                     mkCFA >name n>count loadr mkCFA -> srcOpen
  339.                      xline putLine: dpane
  340.                      lock: tempstr get: tempstr print: dwind unlock: tempstr show: dwind
  341.                      release: tempstr 
  342.                 ELSE xline moveto: dpane
  343.                 THEN
  344.             ELSE ." word not marked"
  345.             THEN
  346.         ELSE ." word not marked"
  347.         THEN
  348.     ELSE ." not found"
  349.     THEN  ;
  350.  
  351. \ : qhit? ( n n - b) drop $ ff and ascii q = ;
  352. \ 
  353. \ \ for testing textctl entries
  354. \ : kk BEGIN
  355. \         next: fevent
  356. \         IF actw fwind =
  357. \             IF  qhit?
  358. \                 IF exit THEN
  359. \             ELSE drop key: actw
  360. \             THEN
  361. \         THEN
  362. \     AGAIN ;
  363.  
  364.  
  365. ;module
  366.